home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / top.scm < prev    next >
Text File  |  1995-10-22  |  10KB  |  293 lines
  1. ;;; The scsh argv switch parser.
  2. ;;; Copyright (c) 1995 by Olin Shivers.
  3.  
  4. ;;; Imports:
  5. ;;;    COMMAND-PROCESSOR: set-batch-mode?! command-loop
  6. ;;;     ENSURES-LOADED: really-ensure-loaded
  7. ;;;     ENVIRONMENTS: set-interaction-environment! environment-ref
  8. ;;;        environment-define!
  9. ;;;    ERROR-PACKAGE: error
  10. ;;;     EVALUATION: eval
  11. ;;;     EXTENDED-PORTS: make-string-input-port
  12. ;;;    INTERFACES: make-simple-interface
  13. ;;;     INTERRUPTS: interrupt-before-heap-overflow!
  14. ;;;     PACKAGE-COMMANDS-INTERNAL: user-environment config-package 
  15. ;;;        get-reflective-tower
  16. ;;;     PACKAGE-MUTATION: package-open!
  17. ;;;    PACKAGES: structure-package structure? make-structure 
  18. ;;;        make-simple-package
  19. ;;;    RECEIVING: mv return stuff
  20. ;;;    SCSH-LEVEL-0-INTERNALS: set-command-line-args!
  21. ;;;    SCSH-VERSION: scsh-version-string
  22. ;;;    
  23.  
  24. ;;; This should be defined by the package code, but it isn't.
  25.  
  26. (define (get-struct config-pack struct-name)
  27.   (let ((s (environment-ref config-pack struct-name)))
  28.     (cond ((structure? s) s)
  29.       (else (error "not a structure" s struct-name)))))
  30.  
  31. ;;; The switches:
  32. ;;;     -o <struct>        Open the structure in current package.
  33. ;;;     -n <package>        Create new package, make it current package.
  34. ;;;     -m <struct>        <struct>'s package becomes current package.
  35. ;;;     
  36. ;;;     -l  <file>        Load <file> into current package.
  37. ;;;    -lm <file>        Load <file> into config package.
  38. ;;;
  39. ;;;                             These two require terminating -s <script> arg:
  40. ;;;     -ds            Load terminating script into current package.
  41. ;;;     -dm            Load terminating script into config package.
  42. ;;;     
  43. ;;;     -e <entry>        Call (<entry>) to start program.
  44. ;;;     
  45. ;;;                Terminating switches:
  46. ;;;     -c <exp>        Eval <exp>, then exit.
  47. ;;;     -s <script>        Specify <script> to be loaded by a -ds or -dm.
  48. ;;;     --              Interactive scsh.
  49.  
  50.  
  51. ;;; Return switch list, terminating switch, with arg, top-entry, 
  52. ;;; and command-line args. 
  53. ;;; - We first expand out any initial \ <filename> meta-arg.
  54. ;;; - A switch-list elt is either "-ds", "-dm", or a (switch . arg) pair
  55. ;;;   for a -o, -n, -m, -l, or -lm switch.
  56. ;;; - Terminating switch is one of {s, c, #f} for -s, -c, and -- respectively.
  57. ;;; - Terminating arg is the <exp> arg to -c, the <script> arg to -s, otw #f.
  58. ;;; - top-entry is the <entry> arg to a -e; #f if none.
  59. ;;; - command-line args are what's left over after picking off the scsh
  60. ;;;   switches.
  61.  
  62. (define (parse-scsh-args args)
  63.   (let lp ((args (meta-arg-process-arglist args))
  64.        (switches '())    ; A list of handler thunks
  65.        (top-entry #f)    ; -t <entry>
  66.        (need-script? #f))    ; Found a -ds or -dm?
  67.     (if (pair? args)
  68.     (let ((arg  (car args))
  69.           (args (cdr args)))
  70.  
  71.       (cond ((string=? arg "-c")
  72.          (if (or need-script? top-entry (not (pair? args)))
  73.              (bad-arg)
  74.              (values (reverse switches) 'c (car args)
  75.                  top-entry (cdr args))))
  76.  
  77.         ((string=? arg "-s")
  78.          (if (not (pair? args))
  79.              (bad-arg "-s switch requires argument")
  80.              (values (reverse switches) 's (car args)
  81.                  top-entry (cdr args))))
  82.  
  83.         ((string=? arg "--")
  84.          (if need-script?
  85.              (bad-arg "-ds or -dm switch requires -s <script>")
  86.              (values (reverse switches) #f #f top-entry args)))
  87.  
  88.         ((or (string=? arg "-ds")
  89.              (string=? arg "-dm"))
  90.          (lp args (cons arg switches) top-entry #t))
  91.         
  92.         ((or (string=? arg "-l")
  93.              (string=? arg "-lm"))
  94.          (if (pair? args)
  95.              (lp (cdr args)
  96.              (cons (cons arg (car args)) switches)
  97.              top-entry
  98.              need-script?)
  99.              (bad-arg "Switch requires argument" arg)))
  100.  
  101.         ((or (string=? arg "-o")
  102.              (string=? arg "-n")
  103.              (string=? arg "-m"))
  104.          (if (pair? args)
  105.              (let* ((s (car args))
  106.                 (name (if (and (string=? arg "-n")
  107.                        (string=? s "#f"))
  108.                       #f ; -n #f  treated specially.
  109.                       (string->symbol s))))
  110.                (lp (cdr args)
  111.                (cons (cons arg name) switches)
  112.                top-entry
  113.                need-script?))
  114.              (bad-arg "Switch requires argument" arg)))
  115.  
  116.         ((string=? arg "-e")
  117.          (lp (cdr args)                  switches
  118.              (string->symbol (car args)) need-script?))
  119.  
  120.         (else (bad-arg "Unknown switch" arg))))
  121.  
  122.     (values (reverse switches) #f #f top-entry '()))))
  123.  
  124.  
  125. ;;; Do each -ds, -dm, -o, -n, -m, -l, and -lm switch, and return the final 
  126. ;;; result package and a flag saying if the script was loaded by a -ds or -dm.
  127.  
  128. (define (do-switches switches script-file)
  129. ; (format #t "Switches = ~a~%" switches)
  130.   (let lp ((switches switches)
  131.        (script-loaded? #f))
  132.     (if (pair? switches)
  133.     (let ((switch (car switches))
  134.           (switches (cdr switches)))
  135. ;      (format #t "Doing switch ~a~%" switch)
  136.       (cond
  137.  
  138.         ((equal? switch "-ds")
  139.          (load-quietly script-file (interaction-environment))
  140. ;         (format #t "loaded script ~s~%" script-file)
  141.          (lp switches #t))
  142.  
  143.         ((equal? switch "-dm")
  144.          (load-quietly script-file (config-package))
  145. ;         (format #t "loaded module ~s~%" script-file)
  146.          (lp switches #t))
  147.  
  148.         ((string=? (car switch) "-l")
  149. ;         (format #t "loading file ~s~%" (cdr switch))
  150.          (load-quietly (cdr switch) (interaction-environment))
  151.          (lp switches script-loaded?))
  152.  
  153.         ((string=? (car switch) "-lm")
  154. ;         (format #t "loading module file ~s~%" (cdr switch))
  155.          (load-quietly (cdr switch) (config-package))
  156.          (lp switches script-loaded?))
  157.  
  158.         ((string=? (car switch) "-o")
  159.          (let ((struct-name (cdr switch))
  160.            (cp (config-package)))
  161.            ;; Should not be necessary to do this ensure-loaded, but it is.
  162.            (really-ensure-loaded #f (get-struct cp struct-name))
  163.            (package-open! (interaction-environment)
  164.                   (lambda () (get-struct cp struct-name)))
  165. ;           (format #t "Opened ~s~%" struct-name)
  166.            (lp switches script-loaded?)))
  167.  
  168.         ((string=? (car switch) "-n")
  169.          (let* ((name (cdr switch))
  170.             (pack (new-empty-package name)))    ; Contains nothing
  171.            (if name                    ; & exports nothing.
  172.            (let* ((iface  (make-simple-interface #f '()))
  173.               (struct (make-structure pack iface)))
  174.              (environment-define! (config-package) name struct)))
  175.            (set-interaction-environment! pack)
  176.            (lp switches script-loaded?)))
  177.  
  178.         ((string=? (car switch) "-m")
  179. ;         (format #t "struct-name ~s~%" (cdr switch))
  180.          (let ((struct (get-struct (config-package) (cdr switch))))
  181. ;           (format #t "struct-name ~s, struct ~s~%" (cdr switch) struct)
  182.            (let ((pack (structure-package struct)))
  183. ;         (format #t "package ~s~%" pack)
  184.          (set-interaction-environment! pack)
  185.          (really-ensure-loaded #f struct)
  186. ;         (format #t "Switched to ~s~%" pack)
  187.          (lp switches script-loaded?))))
  188.  
  189.         (else (error "Impossible error in do-switches. Report to developers."))))
  190.     script-loaded?)))
  191.         
  192.  
  193. ;;; (user-environment) probably isn't right. What is this g-r-t stuff?
  194. ;;; Check w/jar.
  195.  
  196. (define (new-empty-package name)
  197.   (make-simple-package '() #t
  198.                (get-reflective-tower (user-environment)) ; ???
  199.                name))
  200.  
  201.  
  202. (define (parse-switches-and-execute args context)
  203.   (receive (switches term-switch term-val top-entry args)
  204.            (parse-scsh-args args)
  205.     ((with-new-session context    ; "Log in" user.
  206.               (current-input-port) (current-output-port)
  207.               args
  208.               term-switch    ; batch? (or interactive?)
  209.        (lambda ()
  210.      (with-interaction-environment (user-environment) ; <-- from CONTEXT.
  211.            (lambda ()
  212.          ;; Have to do these before calling DO-SWITCHES, because actions
  213.          ;; performed while processing the switches may use these guys.
  214.          (set-command-line-args!
  215.              (cons (if (eq? term-switch 's) term-val "scsh")
  216.                args))
  217.  
  218.          ;; Set HOME-DIRECTORY and EXEC-PATH-LIST,
  219.          ;; quietly if not running an interactive script.
  220.          (init-scsh-vars term-switch)
  221.  
  222.          (let ((script-loaded? (do-switches switches term-val)))
  223.            (if (and (not script-loaded?)    ; There wasn't a -ds or -dm,
  224.             (eq? term-switch 's))    ; but there is a script,
  225.            (load-quietly term-val    ; so load it now.
  226.                  (interaction-environment)))
  227.  
  228.            (cond ((not term-switch) ; -- interactive
  229.               (interrupt-before-heap-overflow!)
  230.               (command-loop (lambda ()
  231.                       (display "Scsh ")
  232.                       (display scsh-version-string)
  233.                       (newline))
  234.                     #f))
  235.              ;; COMMAND-LOOP returns a continuation when it exits,
  236.              ;; which gets invoked outside the W-N-S above. I.e.,
  237.              ;; we "log out" and start over.
  238.  
  239.  
  240.              ((eq? term-switch 'c)
  241.               (eval (read-exactly-one-sexp-from-string term-val)
  242.                 (interaction-environment))
  243.               (exit 0))
  244.  
  245.              (top-entry        ; There was a -e <entry>.
  246.               ((eval top-entry (interaction-environment))
  247.                (command-line))
  248.               (exit 0))
  249.  
  250.              ;; Otherwise, the script executed as it loaded,
  251.              ;; so we're done.
  252.              (else (exit 0))
  253.              )))))))))
  254.  
  255.  
  256. (define (read-exactly-one-sexp-from-string s)
  257.   (with-current-input-port (make-string-input-port s)
  258.     (let ((val (read)))
  259.       (if (eof-object? (read)) val
  260.       (error "More than one value read from string" s)))))
  261.  
  262.  
  263. (define (bad-arg . msg)
  264.   (with-current-output-port (error-output-port)
  265.     (for-each (lambda (x) (display x) (write-char #\space)) msg)
  266.     (newline)
  267.     (display "Useage: scsh [meta-arg] [switch ..] [end-option arg ...]
  268.  
  269. meta-arg: \\ <script-file-name>
  270.  
  271. switch:    -e <entry-point>    Specify top-level entry point.
  272.     -o <structure>        Open structure in current package.
  273.     -m <package>        Switch to package.
  274.     -n <new-package>    Switch to new package.
  275.  
  276.  
  277.     -lm <module-file-name>    Load module into config package.
  278.     -l  <file-name>        Load file into current package.
  279.  
  280.     -ds             Do script.
  281.     -dm            Do script module.
  282.  
  283. end-option:    -s <script>
  284.         -c <exp>
  285.         --
  286. "))
  287.   (exit -1))
  288.  
  289.  
  290. (define (repl)
  291.   (command-loop (lambda () (set-batch-mode?! #f))
  292.         #f))
  293.